home *** CD-ROM | disk | FTP | other *** search
/ PC World Komputer 2010 April / PCWorld0410.iso / hity wydania / Ubuntu 9.10 PL / karmelkowy-koliberek-desktop-9.10-i386-PL.iso / casper / filesystem.squashfs / usr / share / perl5 / Mail / Internet.pm < prev    next >
Text File  |  2008-11-04  |  12KB  |  552 lines
  1. # Copyrights 1995-2008 by Mark Overmeer <perl@overmeer.net>.
  2. #  For other contributors see ChangeLog.
  3. # See the manual pages for details on the licensing terms.
  4. # Pod stripped from pm file by OODoc 1.05.
  5. package Mail::Internet;
  6. use vars '$VERSION';
  7. $VERSION = '2.04';
  8.  
  9. use strict;
  10. # use warnings?  probably breaking too much code
  11.  
  12. use Carp;
  13. use Mail::Header;
  14. use Mail::Util    qw/mailaddress/;
  15. use Mail::Address;
  16.  
  17.  
  18. sub new(@)
  19. {   my $call  = shift;
  20.     my $arg   = @_ % 2 ? shift : undef;
  21.     my %opt   = @_;
  22.  
  23.     my $class = ref($call) || $call;
  24.     my $self  = bless {}, $class;
  25.  
  26.     $self->{mail_inet_head} = $opt{Header} if exists $opt{Header};
  27.     $self->{mail_inet_body} = $opt{Body}   if exists $opt{Body};
  28.  
  29.     my $head = $self->head;
  30.     $head->fold_length(delete $opt{FoldLength} || 79);
  31.     $head->mail_from($opt{MailFrom}) if exists $opt{MailFrom};
  32.     $head->modify(exists $opt{Modify} ? $opt{Modify} : 1);
  33.  
  34.     if(!defined $arg) { }
  35.     elsif(ref($arg) eq 'ARRAY')
  36.     {   $self->header($arg) unless exists $opt{Header};
  37.         $self->body($arg)   unless exists $opt{Body};
  38.     }
  39.     elsif(defined fileno($arg))
  40.     {   $self->read_header($arg) unless exists $opt{Header};
  41.         $self->read_body($arg)   unless exists $opt{Body};
  42.     }
  43.     else
  44.     {   croak "couldn't understand $arg to Mail::Internet constructor";
  45.     }
  46.  
  47.     $self;
  48. }
  49.  
  50.  
  51. sub read(@)
  52. {   my $self = shift;
  53.     $self->read_header(@_);
  54.     $self->read_body(@_);
  55. }
  56.  
  57. sub read_body($)
  58. {   my ($self, $fd) = @_;
  59.     $self->body( [ <$fd> ] );
  60. }
  61.  
  62. sub read_header(@)
  63. {   my $head = shift->head;
  64.     $head->read(@_);
  65.     $head->header;
  66. }
  67.  
  68.  
  69. sub extract($)
  70. {   my ($self, $lines) = @_;
  71.     $self->head->extract($lines);
  72.     $self->body($lines);
  73. }
  74.  
  75.  
  76. sub dup()
  77. {   my $self = shift;
  78.     my $dup  = ref($self)->new;
  79.  
  80.     my $body = $self->{mail_inet_body} || [];
  81.     my $head = $self->{mail_inet_head};;
  82.  
  83.     $dup->{mail_inet_body} = [ @$body ];
  84.     $dup->{mail_inet_head} = $head->dup if $head;
  85.     $dup;
  86. }
  87.  
  88.  
  89. sub body(;$@)
  90. {   my $self = shift;
  91.  
  92.     return $self->{mail_inet_body} ||= []
  93.         unless @_;
  94.  
  95.     $self->{mail_inet_body} = ref $_[0] eq 'ARRAY' ? $_[0] : [ @_ ];
  96. }
  97.  
  98.  
  99. sub head         { shift->{mail_inet_head} ||= Mail::Header->new }
  100.  
  101.  
  102. sub print($)
  103. {   my $self = shift;
  104.     my $fd   = shift || \*STDOUT;
  105.  
  106.     $self->print_header($fd)
  107.        and print $fd "\n"
  108.        and $self->print_body($fd);
  109. }
  110.  
  111.  
  112. sub print_header($) { shift->head->print(@_) }
  113.  
  114. sub print_body($)
  115. {   my $self = shift;
  116.     my $fd   = shift || \*STDOUT;
  117.  
  118.     foreach my $ln (@{$self->body})
  119.     {    print $fd $ln or return 0;
  120.     }
  121.  
  122.     1;
  123. }
  124.  
  125.  
  126. sub as_string()
  127. {   my $self = shift;
  128.     $self->head->as_string . "\n" . join '', @{$self->body};
  129. }
  130.  
  131.  
  132. sub as_mbox_string($)
  133. {   my $self    = shift->dup;
  134.     my $escaped = shift;
  135.  
  136.     $self->head->delete('Content-Length');
  137.     $self->escape_from unless $escaped;
  138.     $self->as_string . "\n";
  139. }
  140.  
  141.  
  142. sub header       { shift->head->header(@_) }
  143. sub fold         { shift->head->fold(@_) }
  144. sub fold_length  { shift->head->fold_length(@_) }
  145. sub combine      { shift->head->combine(@_) }
  146.  
  147.  
  148. sub add(@)
  149. {   my $head = shift->head;
  150.     my $ret;
  151.     while(@_)
  152.     {   my ($tag, $line) = splice @_, 0, 2;
  153.         $ret = $head->add($tag, $line, -1)
  154.             or return undef;
  155.     }
  156.  
  157.     $ret;
  158. }
  159.  
  160.  
  161. sub replace(@)
  162. {   my $head = shift->head;
  163.     my $ret;
  164.  
  165.     while(@_)
  166.     {   my ($tag, $line) = splice @_, 0, 2;
  167.         $ret = $head->replace($tag, $line, 0)
  168.              or return undef;
  169.     }
  170.  
  171.     $ret;
  172. }
  173.  
  174.  
  175. sub get(@)
  176. {   my $head = shift->head;
  177.  
  178.     return map { $head->get($_) } @_
  179.         if wantarray;
  180.  
  181.     foreach my $tag (@_)
  182.     {   my $r = $head->get($tag);
  183.         return $r if defined $r;
  184.     }
  185.  
  186.     undef;
  187. }
  188.  
  189.  
  190. sub delete(@)
  191. {   my $head = shift->head;
  192.     map { $head->delete($_) } @_;
  193. }
  194.  
  195. # Undocumented; unused???
  196. sub empty()
  197. {   my $self = shift;
  198.     %$self = ();
  199.     1;
  200. }
  201.  
  202.  
  203. sub remove_sig($)
  204. {   my $body   = shift->body;
  205.     my $nlines = shift || 10;
  206.     my $start  = @$body;
  207.  
  208.     my $i    = 0;
  209.     while($i++ < $nlines && $start--)
  210.     {   next if $body->[$start] !~ /^--[ ]?[\r\n]/;
  211.  
  212.         splice @$body, $start, $i;
  213.         last;
  214.     }
  215. }
  216.  
  217.  
  218. sub sign(@)
  219. {   my ($self, %arg) = @_;
  220.     my ($sig, @sig);
  221.  
  222.     if($sig = delete $arg{File})
  223.     {   local *SIG;
  224.  
  225.         if(open(SIG, $sig))
  226.         {   local $_;
  227.             while(<SIG>) { last unless /^(--)?\s*$/ }
  228.             @sig = ($_, <SIG>, "\n");
  229.             close SIG;
  230.         }
  231.     }
  232.     elsif($sig = delete $arg{Signature})
  233.     {    @sig = ref($sig) ? @$sig : split(/\n/, $sig);
  234.     }
  235.  
  236.     if(@sig)
  237.     {   $self->remove_sig;
  238.         s/[\r\n]*$/\n/ for @sig;
  239.         push @{$self->body}, "-- \n", @sig;
  240.     }
  241.  
  242.     $self;
  243. }
  244.  
  245.  
  246. sub tidy_body()
  247. {   my $body = shift->body;
  248.  
  249.     shift @$body while @$body && $body->[0]  =~ /^\s*$/;
  250.     pop @$body   while @$body && $body->[-1] =~ /^\s*$/;
  251.     $body;
  252. }
  253.  
  254.  
  255. sub reply(@)
  256. {   my ($self, %arg) = @_;
  257.     my $class = ref $self;
  258.     my @reply;
  259.  
  260.     local *MAILHDR;
  261.     if(open(MAILHDR, "$ENV{HOME}/.mailhdr")) 
  262.     {    # User has defined a mail header template
  263.          @reply = <MAILHDR>;
  264.          close MAILHDR;
  265.     }
  266.  
  267.     my $reply = $class->new(\@reply);
  268.  
  269.     # The Subject line
  270.     my $subject = $self->get('Subject') || "";
  271.     $subject = "Re: " . $subject
  272.         if $subject =~ /\S+/ && $subject !~ /Re:/i;
  273.  
  274.     $reply->replace(Subject => $subject);
  275.  
  276.     # Locate who we are sending to
  277.     my $to = $self->get('Reply-To')
  278.           || $self->get('From')
  279.           || $self->get('Return-Path')
  280.           || "";
  281.  
  282.     my $sender = (Mail::Address->parse($to))[0];
  283.  
  284.     my $name = $sender->name;
  285.     unless(defined $name)
  286.     {    my $fr = $self->get('From');
  287.          defined $fr and $fr   = (Mail::Address->parse($fr))[0];
  288.          defined $fr and $name = $fr->name;
  289.     }
  290.  
  291.     my $indent = $arg{Indent} || ">";
  292.     if($indent =~ /\%/) 
  293.     {   my %hash = ( '%' => '%');
  294.         my @name = $name ? grep( {length $_} split /[\n\s]+/, $name) : '';
  295.  
  296.         $hash{f} = $name[0];
  297.         $hash{F} = $#name ? substr($hash{f},0,1) : $hash{f};
  298.  
  299.         $hash{l} = $#name ? $name[$#name] : "";
  300.         $hash{L} = substr($hash{l},0,1) || "";
  301.  
  302.         $hash{n} = $name || "";
  303.         $hash{I} = join "", map {substr($_,0,1)} @name;
  304.  
  305.         $indent  =~ s/\%(.)/defined $hash{$1} ? $hash{$1} : $1/eg;
  306.     }
  307.  
  308.     my $id     = $sender->address;
  309.     $reply->replace(To => $id);
  310.  
  311.     # Find addresses not to include
  312.     my $mailaddresses = $ENV{MAILADDRESSES} || "";
  313.  
  314.     my %nocc = (lc($id) => 1);
  315.     $nocc{lc $_->address} = 1
  316.         for Mail::Address->parse($reply->get('Bcc'), $mailaddresses);
  317.  
  318.     if($arg{ReplyAll})   # Who shall we copy this to
  319.     {   my %cc;
  320.         foreach my $addr (Mail::Address->parse($self->get('To'), $self->get('Cc'))) 
  321.         {   my $lc   = lc $addr->address;
  322.             $cc{$lc} = $addr->format
  323.                  unless $nocc{$lc};
  324.         }
  325.         my $cc = join ', ', values %cc;
  326.         $reply->replace(Cc => $cc);
  327.     }
  328.  
  329.     # References
  330.     my $refs    = $self->get('References') || "";
  331.     my $mid     = $self->get('Message-Id');
  332.  
  333.     $refs      .= " " . $mid if defined $mid;
  334.     $reply->replace(References => $refs);
  335.  
  336.     # In-Reply-To
  337.     my $date    = $self->get('Date');
  338.     my $inreply = "";
  339.  
  340.     if(defined $mid)
  341.     {    $inreply  = $mid;
  342.          $inreply .= ' from ' . $name if defined $name;
  343.          $inreply .= ' on '   . $date if defined $date;
  344.     }
  345.     elsif(defined $name)
  346.     {    $inreply  = $name    . "'s message";
  347.          $inreply .= "of "    . $date if defined $date;
  348.     }
  349.     $reply->replace('In-Reply-To' => $inreply);
  350.  
  351.     # Quote the body
  352.     my $body  = $reply->body;
  353.     @$body = @{$self->body};    # copy body
  354.     $reply->remove_sig;
  355.     $reply->tidy_body;
  356.     s/\A/$indent/ for @$body;
  357.  
  358.     # Add references
  359.     unshift @{$body}, (defined $name ? $name . " " : "") . "<$id> writes:\n";
  360.  
  361.     if(defined $arg{Keep} && ref $arg{Keep} eq 'ARRAY')      # Include lines
  362.     {   foreach my $keep (@{$arg{Keep}}) 
  363.         {    my $ln = $self->get($keep);
  364.              $reply->replace($keep => $ln) if defined $ln;
  365.         }
  366.     }
  367.  
  368.     if(defined $arg{Exclude} && ref $arg{Exclude} eq 'ARRAY') # Exclude lines
  369.     {    $reply->delete(@{$arg{Exclude}});
  370.     }
  371.  
  372.     $reply->head->cleanup;      # remove empty header lines
  373.     $reply;
  374. }
  375.  
  376.  
  377. sub smtpsend($@)
  378. {   my ($self, %opt) = @_;
  379.  
  380.     require Net::SMTP;
  381.     require Net::Domain;
  382.  
  383.     my $host     = $opt{Host};
  384.     my $envelope = $opt{MailFrom} || mailaddress();
  385.     my $quit     = 1;
  386.  
  387.     my ($smtp, @hello);
  388.  
  389.     push @hello, Hello => $opt{Hello}
  390.         if defined $opt{Hello};
  391.  
  392.     push @hello, Port => $opt{Port}
  393.     if exists $opt{Port};
  394.  
  395.     push @hello, Debug => $opt{Debug}
  396.     if exists $opt{Debug};
  397.  
  398.     if(!defined $host)
  399.     {   local $SIG{__DIE__};
  400.     my @hosts = qw(mailhost localhost);
  401.     unshift @hosts, split /\:/, $ENV{SMTPHOSTS}
  402.             if defined $ENV{SMTPHOSTS};
  403.  
  404.     foreach $host (@hosts)
  405.         {   $smtp = eval { Net::SMTP->new($host, @hello) };
  406.         last if defined $smtp;
  407.     }
  408.     }
  409.     elsif(ref($host) && UNIVERSAL::isa($host,'Net::SMTP'))
  410.     {   $smtp = $host;
  411.     $quit = 0;
  412.     }
  413.     else
  414.     {   local $SIG{__DIE__};
  415.     $smtp = eval { Net::SMTP->new($host, @hello) };
  416.     }
  417.  
  418.     defined $smtp or return ();
  419.  
  420.     my $head = $self->cleaned_header_dup;
  421.  
  422.     # Who is it to
  423.  
  424.     my @rcpt = map { ref $_ ? @$_ : $_ } grep { defined } @opt{'To','Cc','Bcc'};
  425.     @rcpt    = map { $head->get($_) } qw(To Cc Bcc)
  426.     unless @rcpt;
  427.  
  428.     my @addr = map {$_->address} Mail::Address->parse(@rcpt);
  429.     @addr or return ();
  430.  
  431.     $head->delete('Bcc');
  432.  
  433.     # Send it
  434.  
  435.     my $ok = $smtp->mail($envelope)
  436.           && $smtp->to(@addr)
  437.           && $smtp->data(join("", @{$head->header}, "\n", @{$self->body}));
  438.  
  439.     $quit && $smtp->quit;
  440.     $ok ? @addr : ();
  441. }
  442.  
  443.  
  444. sub send($@)
  445. {   my ($self, $type, @args) = @_;
  446.  
  447.     require Mail::Mailer;
  448.  
  449.     my $head  = $self->cleaned_header_dup;
  450.     my $mailer = Mail::Mailer->new($type, @args);
  451.  
  452.     $mailer->open($head->header_hashref);
  453.     $self->print_body($mailer);
  454.     $mailer->close;
  455. }
  456.  
  457.  
  458. sub nntppost
  459. {   my ($self, %opt) = @_;
  460.  
  461.     require Net::NNTP;
  462.  
  463.     my $groups = $self->get('Newsgroups') || "";
  464.     my @groups = split /[\s,]+/, $groups;
  465.     @groups or return ();
  466.  
  467.     my $head   = $self->cleaned_header_dup;
  468.  
  469.     # Remove these incase the NNTP host decides to mail as well as me
  470.     $head->delete(qw(To Cc Bcc)); 
  471.  
  472.     my $news;
  473.     my $quit   = 1;
  474.  
  475.     my $host   = $opt{Host};
  476.     if(ref($host) && UNIVERSAL::isa($host,'Net::NNTP'))
  477.     {   $news = $host;
  478.     $quit = 0;
  479.     }
  480.     else
  481.     {   my @opt = $opt{Host};
  482.  
  483.     push @opt, Port => $opt{Port}
  484.         if exists $opt{Port};
  485.  
  486.     push @opt, Debug => $opt{Debug}
  487.         if exists $opt{Debug};
  488.  
  489.     $news = Net::NNTP->new(@opt)
  490.         or return ();
  491.     }
  492.  
  493.     $news->post(@{$head->header}, "\n", @{$self->body});
  494.     my $rc = $news->code;
  495.  
  496.     $news->quit if $quit;
  497.  
  498.     $rc == 240 ? @groups : ();
  499. }
  500.  
  501.  
  502. sub escape_from
  503. {   my $body = shift->body;
  504.     scalar grep { s/\A(>*From) />$1 /o } @$body;
  505. }
  506.  
  507.  
  508.  
  509. sub unescape_from
  510. {   my $body = shift->body;
  511.     scalar grep { s/\A>(>*From) /$1 /o } @$body;
  512. }
  513.  
  514. # Don't tell people it exists
  515. sub cleaned_header_dup()
  516. {   my $head = shift->head->dup;
  517.  
  518.     $head->delete('From '); # Just in case :-)
  519.  
  520.     # An original message should not have any Received lines
  521.     $head->delete('Received');
  522.  
  523.     $head->replace('X-Mailer', "Perl5 Mail::Internet v".$Mail::Internet::VERSION)
  524.         unless $head->count('X-Mailer');
  525.  
  526.     my $name = eval {local $SIG{__DIE__}; (getpwuid($>))[6]} || $ENV{NAME} ||"";
  527.  
  528.     while($name =~ s/\([^\(\)]*\)//) { 1; }
  529.     
  530.     # Strip extra fields: adduser-generated usernames have multiple comma
  531.     # seperated fields, only the first of which should be used to prevent
  532.     # accidental exposure of system-local information like phone numbers/
  533.     # room numbers.
  534.     $name = (split /,/, $name)[0];
  535.  
  536.     if($name =~ /[^\w\s]/)
  537.     {   $name =~ s/"/\"/g;
  538.     $name = '"' . $name . '"';
  539.     }
  540.  
  541.     my $from = sprintf "%s <%s>", $name, mailaddress();
  542.     $from =~ s/\s{2,}/ /g;
  543.  
  544.     foreach my $tag (qw(From Sender))
  545.     {   $head->get($tag) or $head->add($tag, $from);
  546.     }
  547.  
  548.     $head;
  549. }
  550.  
  551. 1;
  552.